00100	(PROG2 (PUTPROP 'I1 (GET 'IF-NEEDED 'FSUBR) 'FSUBR)2)
00200	(DEFUN IF-NEEDED FEXPR (L) (INSERT (APPLY 'I1 L)))
00300	
00400	(COMMENT COMMENT FUNCTIONS)
00500	
00600	(CDEFUN TO-ACHIEVE ('GOAL "REST" 'CODE)
00700	   (COND ((TRUE GOAL) (RETURN 'ALREADY-ACHIEVED)))
00800	 :LP
00900	   (COND ((NULL CODE) (RAN-OUT))
01000	         ((CEVAL (CAR CODE)) (RETURN 'OK)))
01100	   (CSETQ CODE (CDR CODE))
01200	   (GO 'LP))
01300	
01400	(CDEFUN TO-MAKE ('GOAL "REST" 'CODE)
01500	 :LP
01600	   (COND ((NULL CODE) (RAN-OUT))
01700	         ((CEVAL (CAR CODE)) (RETURN 'OK)))
01800	   (CSETQ CODE (CDR CODE))
01900	   (GO 'LP))
02000	
02100	(CDEFUN SETUP ('SETUP 'CODE)
02200	   (CEVAL SETUP)
02300	   (CEVAL CODE))
02400	
02500	(CDEFUN MEANS ('DEF 'CODE) (CEVAL CODE))
02600	
02700	(CDEFUN NEED-ONLY ('SUF 'CODE) (CEVAL CODE))
02800	
02900	(CDEFUN STRATEGY ('AIM 'CODE)
03000	   "AUX"((WINNERS (CONS (LIST (VSUBST GOAL) (CONTROL)) WINNERS)))
03100	   (COND ((TRUE AIM)) (T (CEVAL CODE)))
03200	   NIL)
03300	
03400	(CDEFUN NEEDS ('NECESSARY 'CODE) "AUX"((SAVE CONTEXT))
03500	   (RETURN (CEVAL CODE))
03600	 :BACK
03700	   (COND ((TRUE NECESSARY) (NEEDBACK))
03800	         ((TRUE NECESSARY SAVE) (SCREWED)))
03900	   (DISPLACE (EXPRESSION (FRAME))
04000	      !"(SETUP (ACHIEVE ,NECESSARY) ,CODE))
04100	   (CSETQ CONTEXT SAVE ORIG NIL)
04200	   (CEVAL (EXPRESSION (FRAME)) (ACCESS)))
     

00100	(COMMENT UTILITY FUNCTIONS)
00200	
00300	(DEFUN DISPLACE (TA S)
00400	   (TERPRI)
00500	   (PRINT 'CLOBBERING)
00600	   (SPEW TA)
00700	   (PRINT 'TO)
00800	   (SPEW S)
00900	   (RPLACA TA (CAR S))
01000	   (RPLACD TA (CDR S))
01100	   TA)
01200	
01250	(DEFUN SPEW(X)(TERPRI)(SPRINT X 0 0))
01300	(CDEFUN FOR-EACH-ELEMENT ('ATOM LIST 'EXP)
01400	   (PROGBIND (LIST ATOM)
01500	    :LP
01600	      (COND ((NULL LIST) (RETURN NIL)))
01700	      (CSET ATOM (CAR LIST))
01800	      (CEVAL EXP)
01900	      (CSETQ LIST (CDR LIST))
02000	      (GO 'LP)))
02100	
02200	(CDEFUN FOR-EACH-DATUM ('BIND 'PAT 'EXP) "AUX"(POS (UPOS NIL))
02300	   (PROGBIND BIND
02400	      (CSETQ POS (GENERATE (TRUE1 PAT)))
02500	    :LP
02600	      (TRY-NEXT POS '(RETURN 'T))
02700	      (COND ((UNIQUE) (CEVAL EXP)))
02800	      (GO 'LP)))
02900	
03000	(DEFUN UNIQUE FEXPR (L) (PROG (E)
03100	   (SETQ L (CDR (VLOC 'UPOS)) E (MAPCAR 'RVALUE ,BIND))
03200	   (COND ((MEMBER E (CAR L)) (RETURN NIL)))
03300	   (RPLACA L (CONS E (CAR L)))
03400	   (RETURN T)))
03500	
03600	(CDEFUN IF ('COND 'EXP)
03700	   (COND ((TRUE COND) (CEVAL EXP (ACCESS)))))
     

00100	(COMMENT PROTECTION STUFF)
00200	
00300	(DEFUN PROTECT FEXPR (L)
00400	   (CSET 'PROTECTEDS (CONS (VSUBST (CAR L)) ,PROTECTEDS)))
00500	
00600	(CDEFUN PROTECTED ('EXP) "AUX"((CONTEXT (PUSH-CONTEXT)))
00700	   (REMOVE (VSUBST EXP))
00800	   (FOR-EACH-ELEMENT P PROTECTEDS
00900	      (COND ((TRUE P)) (T (RETURN T)))))
01000	
01100	(CDEFUN CHECK-PROTECTEDS ()
01200	   (FOR-EACH-ELEMENT P PROTECTEDS
01300	      (COND ((TRUE P)) (T (BUG PROTECTION-VIOLATION ,P)))))
01400	
01500	(IF-REMOVED MDB1 (NOT !>X) (ADD X))
01600	(INSERT 'MDB1)
01700	
01800	(CSETQ PROTECTEDS ())
01900	
02000	(DEFUN VSUBST (EXP)
02100	   (COND ((ATOM EXP) EXP)
02200	         ((EQ (CAR EXP) '/!/,) (RVALUE (CADR EXP)))
02300	         ((EQ (CAR EXP) '/!/;)
02400	          (COND ((ASSIGNED? (CADR EXP)) (RVALUE (CADR EXP)))
02500	                (T (LISTEN 'VSUBST-LOSE))))
02600	         (T (CONS (VSUBST (CAR EXP)) (VSUBST (CDR EXP))))))
02700	
02800	
02900	(DEFUN PREFIX (P V E) (PREFIX1 E))
03000	
03100	(DEFUN PREFIX1 (E)
03200	   (COND ((ATOM E)
03300	          (COND ((MEMQ E V) (LIST P E))  (T E)))
03400	         (T (CONS (PREFIX1 (CAR E)) (PREFIX1 (CDR E))))))
03500	
03600	
03700	(CDEFUN CHOOSE ('GOAL) 
03800	   (COND ((TRUE !"(POSSIBLE ,GOAL)))
03900	         (T (LISTEN !"(CAN NOT CHOOSE ,GOAL)))))
04000	
04100	
04200	(CDEFUN WINTEST () "AUX"((W (REVERSE WINNERS)))
04300	   :LP
04400	   (COND ((NULL W)(RETURN NIL))
04500	         ((TRUE (CAAR W)) (CONTINUE (CADAR W) 'OK)))
04600	   (CSETQ W (CDR W))
04700	   (GO 'LP))
04800	
04900	(CSETQ WINNERS ())
     

00100	(COMMENT HASH TABLE STUFF)
00200	
00300	(DEFUN GETP (EXP IND) (ASSOC IND (HASH (CDR EXP))))
00400	
00500	(DEFUN PUTP (EXP PROP IND)
00600	   ((LAMBDA (HASH)
00700	      (COND ((SETQ EXP (ASSOC IND HASH)) (RPLACA (CDR EXP) PROP))
00800	            (T (NCONC HASH (LIST (LIST IND PROP))))))
00900	    (HASH (CDR EXP))))
01000	
01100	(DEFUN HASH (EXP) (PROG (N F A)
01200	   (SETQ N (REMAINDER (MAKNUM EXP 'FIXNUM) TABSIZ))
01300	 LP(COND ((EQ (CAR (SETQ A (TAB N))) EXP) (RETURN A))
01400	         ((NULL (TAB N)) (STORE (TAB N) (SETQ A (LIST EXP)))
01500	          (RETURN A))
01600	         ((MINUSP (SETQ N (SUB1 N)))
01700	          (COND (F (CERR FULL HSHTAB)))
01800	          (SETQ F T  N (SUB1 TABSIZ))))
01900	   (GO LP)))
02000	
02100	(SETQ TABSIZ 500)
02200	(ARRAY TAB T TABSIZ)
02300